home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / monolith / ISTQP.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  4.1 KB  |  128 lines
  1.         PROGRAM ISTQP
  2.  
  3.         INTEGER SRCPTH(134),OUTPTH(134),PLOPTH(134),
  4.      +          CIPTH(134),TMPPTH(134),OPTSTR(134),I,STATUS,
  5.      +          IODSRC,IODOUT,IODTMP,TOKNUM,IODCI,NERROR,NWARN,DESCI,
  6.      +          PLOPT(134),IODPLO
  7.  
  8.         INTEGER TMPFIL
  9.  
  10.         INTEGER YPARSE,GETARG,OPEN,CREATE,ZYINCI,ZTKPTI,ZTKGTI
  11.         EXTERNAL YPARSE,ZINIT,ZMESS,REMARK,ZQUIT,GETARG,OPEN,CREATE,
  12.      +           ZCHOUT,ZPTINT,PUTCH,REMOVE,SEEK,ZYINCI,ZTKPTI,ZTKGTI
  13.  
  14.         DATA (TMPPTH(I),I=1,11)/108,121,112,99,109,116,46,
  15.      +116,109,112,129/,
  16.      +       (CIPTH(I),I=1,11)/108,121,112,99,109,105,46,
  17.      +116,109,112,129/
  18.  
  19.         CALL ZINIT
  20.         CALL INISTR
  21.         CALL INISYM
  22.         CALL INITRE
  23.  
  24.         IF (GETARG(1,SRCPTH,81).EQ.-100) CALL NAMES(1,SRCPTH)
  25.         IF (GETARG(2,OUTPTH,81).EQ.-100) CALL NAMES(2,OUTPTH)
  26.         IF (GETARG(3,OPTSTR,81).EQ.-100) CALL NAMES(3,OPTSTR)
  27.         IF (GETARG(4,PLOPTH,81).EQ.-100) CALL NAMES(4,PLOPTH)
  28.  
  29.         IODSRC=OPEN(SRCPTH,0)
  30.         IF (IODSRC.EQ.-1) CALL ERROR('Source File Open Failed')
  31.         IODOUT=CREATE(OUTPTH,1)
  32.         IF (IODOUT.EQ.-1) CALL ERROR('Output File Create Failed')
  33.         IODPLO=OPEN(PLOPTH,0)
  34.  
  35.         IODTMP=TMPFIL(TMPPTH)
  36.         IODCI=TMPFIL(CIPTH)
  37.         IF (IODTMP.EQ.-1 .OR. IODCI.EQ.-1)
  38.      +      CALL ERROR('Scratch File Creation Failed')
  39.  
  40.         IF (YPARSE(IODSRC,IODTMP,-1,IODCI,NERROR,NWARN).EQ.0) THEN
  41.             IF (NERROR.GT.0) THEN
  42.                 CALL ZCHOUT('[ISTQT Terminated, ',2)
  43.                 CALL ZPTINT(NERROR,1,2)
  44.                 CALL ZCHOUT(' er'//'ror',2)
  45.                 IF (NERROR.GT.1) CALL PUTCH(115,2)
  46.                 CALL ZMESS(']',2)
  47.                 STATUS=-1
  48.             ELSE
  49.                 CALL SEEK(0,IODCI)
  50.                 CALL SEEK(0,IODTMP)
  51.                 IF (ZYINCI(IODCI).EQ.-1) CALL ERROR(
  52.      +              'Internal Error: Couldn''t reread comment index')
  53.                 IF (IODPLO.NE.-1) CALL PLOPTF(IODPLO)
  54.                 DO 100 I=5,10
  55.                     IF (GETARG(I,PLOPT,134).NE.-100)
  56.      +                  CALL POLOPT(PLOPT,.FALSE.)
  57.  100            CONTINUE
  58.                 DESCI=ZTKGTI(2,0,0)
  59.                 CALL PT(OPTSTR,IODTMP,ZTKPTI(0,IODOUT,DESCI),NERROR,
  60.      +                  NWARN)
  61.                 IF (NERROR+NWARN.EQ.0) THEN
  62.                     CALL REMARK('[ISTQP Normal Termination]')
  63.                     STATUS=-2
  64.                 ELSE IF (NERROR.EQ.0) THEN
  65.                     CALL ZCHOUT('[ISTQP Terminated, ',2)
  66.                     CALL ZPTINT(NWARN,1,2)
  67.                     CALL ZCHOUT(' war'//'ning',2)
  68.                     IF (NWARN.GT.1) CALL PUTCH(115,2)
  69.                     CALL ZMESS(']',2)
  70.                     STATUS=-1002
  71.                 ELSE
  72.                     CALL ZCHOUT('[ISTQP Terminated, ',2)
  73.                     CALL ZPTINT(NERROR,1,2)
  74.                     CALL ZCHOUT(' er'//'ror',2)
  75.                     IF (NERROR.GT.1) CALL PUTCH(115,2)
  76.                     CALL ZMESS(']',2)
  77.                     STATUS=-1
  78.                 END IF
  79.             END IF
  80.         ELSE
  81.             CALL REMARK('[ISTQP Fatal Error -- Terminated]')
  82.             STATUS=-1001
  83.         END IF
  84.  
  85.         CALL CLOSE(IODTMP)
  86.         CALL CLOSE(IODCI)
  87.         CALL REMOVE(TMPPTH)
  88.         CALL REMOVE(CIPTH)
  89.  
  90.         CALL ZQUIT(STATUS)
  91.  
  92.         END
  93. C ----------------------------------------------------------------------
  94. C
  95. C       N A M E S   -   Input the pathname of a required file from stdin
  96. C
  97.  
  98.         SUBROUTINE NAMES(NUMBER,PATH)
  99.         INTEGER NUMBER,PATH(*)
  100.  
  101.         INTEGER JUNK,PROMPT(20,4)
  102.  
  103.         SAVE PROMPT
  104.  
  105.         INTEGER ZGTCMD
  106.         EXTERNAL ZGTCMD,ZPRMPT
  107.  
  108. C "Input source file: "
  109. C "Output file: "
  110. C "PT options: "
  111. C "PL option file: "
  112.  
  113.         DATA (PROMPT(I,1),I=1,20)/73,110,112,117,116,32,115,
  114.      +111,117,114,99,101,32,102,105,108,101,58,
  115.      +32,129/,
  116.      +       (PROMPT(I,2),I=1,14)/79,117,116,112,117,116,32,
  117.      +102,105,108,101,58,32,129/,
  118.      +       (PROMPT(I,3),I=1,13)/80,84,32,111,112,116,105,
  119.      +111,110,115,58,32,129/,
  120.      +       (PROMPT(I,4),I=1,17)/80,76,32,111,112,116,105,
  121.      +111,110,32,102,105,108,101,58,32,129/
  122.  
  123.         CALL ZPRMPT(PROMPT(1,NUMBER))
  124.         JUNK=ZGTCMD(PATH,0)
  125.         RETURN
  126.  
  127.         END
  128.